home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / tree-nsubst.lisp < prev    next >
Encoding:
Text File  |  1992-09-11  |  3.2 KB  |  93 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. (defun tree-nsubst (new old tree)
  4.   (if (eq old tree)
  5.       (progn (setf (code-tail? new) (code-tail? old))
  6.          new)
  7.       (unless (null tree)
  8.     (typecase tree
  9.       (seq (tree-nsubst-seq new old tree))
  10.       (scope-control-transfer (tree-nsubst-scope-control-transfer
  11.                    new old tree))
  12.       (unwind-protect (tree-nsubst-unwind-protect new old tree))
  13.       (var-def (tree-nsubst-var-def new old tree))
  14.       (mvalues (tree-nsubst-values new old tree))
  15.       (if (tree-nsubst-if new old tree))
  16.       (switch (tree-nsubst-switch new old tree))
  17.       (function-call (tree-nsubst-function-call new old tree))
  18.       (control-point (tree-nsubst-control-point new old tree))
  19.       (t tree)))))
  20.  
  21. (defun tree-nsubst-list (new old l)
  22.   (loop for rest on l
  23.     do (setf (car rest) (tree-nsubst new old (car rest)))
  24.     finally (return l)))
  25.  
  26. (defun tree-nsubst-seq (new old tree)
  27.   (when (values-seq-p tree)
  28.     (tree-nsubst-list new old (values-seq-values tree)))
  29.   (when (scope-seq-p tree)
  30.     (setf (scope-seq-control-point tree)
  31.       (tree-nsubst-seq new old (scope-seq-control-point tree))))
  32.   (let ((body (seq-body tree)))
  33.     (setf (seq-body tree)
  34.       (if (atom body)
  35.           (tree-nsubst new old body)
  36.           (tree-nsubst-list new old body)))
  37.     tree))
  38.  
  39. (defun tree-nsubst-values (new old tree)
  40.   (tree-nsubst-list new old (mvalues-args tree))
  41.   tree)
  42.  
  43. (defun tree-nsubst-var-def (new old tree)
  44.   (setf (var-def-value tree) (tree-nsubst new old (var-def-value tree)))
  45.   tree)
  46.  
  47. (defun tree-nsubst-function-call (new old tree)
  48.   (when (unnamed-call-p tree)
  49.     (setf (unnamed-call-function-form tree)
  50.       (tree-nsubst new old (unnamed-call-function-form tree))))
  51.   (tree-nsubst-list new old (function-call-args tree))
  52.   tree)
  53.  
  54. (defun tree-nsubst-if (new old tree)
  55.   (setf (if-test tree) (tree-nsubst new old (if-test tree)))
  56.   (setf (if-then tree) (tree-nsubst new old (if-then tree)))
  57.   (setf (if-else tree) (tree-nsubst new old (if-else tree)))
  58.   tree)
  59.  
  60. (defun tree-nsubst-switch (new old tree)
  61.   (setf (branch-test tree) (tree-nsubst new old (branch-test tree)))
  62.   (setf (switch-consequents tree)
  63.     (tree-nsubst-list new old (switch-consequents tree)))
  64.   (setf (switch-default tree) (tree-nsubst new old (switch-default tree)))
  65.   tree)
  66.  
  67. (defun tree-nsubst-scope-control-transfer (new old tree)
  68.   (setf (scope-control-transfer-send-value tree)
  69.     (tree-nsubst new old (scope-control-transfer-send-value tree)))
  70.   (setf (scope-control-transfer-destination-point tree)
  71.     (tree-nsubst new old (scope-control-transfer-destination-point tree)))
  72.   tree)
  73.  
  74.  
  75. (defun tree-nsubst-control-point (new old tree)
  76.   (typecase tree
  77.     (dynamic-scope-control-point
  78.      (setf (dynamic-scope-control-point-tag-name tree)
  79.        (tree-nsubst new old (dynamic-scope-control-point-tag-name tree))))
  80.     (dynamic-tag-control-point
  81.      (setf (dynamic-tag-control-point-tag-name tree)
  82.        (tree-nsubst new old (dynamic-tag-control-point-tag-name tree)))))
  83.   tree)
  84.  
  85. (defun tree-nsubst-unwind-protect (new old tree)
  86.   (setf (unwind-protect-cleanup-form tree)
  87.     (tree-nsubst new old (unwind-protect-cleanup-form tree)))
  88.   (setf (unwind-protect-protected-form tree)
  89.     (tree-nsubst new old (unwind-protect-protected-form tree)))
  90.   tree)
  91.  
  92.  
  93.